(in-package :lilu-apropos)

;;;
;;; Symbol utility functions
;;;


(defparameter *symbol-bounding-types* '(:variable :function :generic-function
                                        :structure :class :macro :setf :type
                                        :special-operator :compiler-macro))

(defun symbol-external-p (symbol)
  "Return t only if the symbol is external"
  (swank::symbol-external-p symbol))

(defun symbol-bound-to (symbol type)
  (let ((description (swank::describe-symbol-for-emacs symbol)))
    (case type
      (:variable
       (getf description :variable))
      (:function
       (and (fboundp symbol)
            (not (typep (symbol-function symbol) 'generic-function))
            (not (macro-function symbol))
            (not (special-operator-p symbol))))
      (:generic-function
       (and (fboundp symbol)
            (typep (symbol-function symbol) 'generic-function)))
      (:macro
       (and (fboundp symbol)
            (macro-function symbol) t))
      (:structure
       (eql (class-of (find-class symbol nil)) (find-class 'structure-class)))
      (:class
       (and (find-class symbol nil)
            (not (eql (class-of (find-class symbol nil)) (find-class 'structure-class)))))
      (:compiler-macro
       (and (compiler-macro-function symbol) t))
      (:setf
       #+sbcl
       (swank/sbcl::setf-expander symbol)
       #+ccl
       (ccl::%setf-method symbol)
       #+ecl
       nil)
      (:type
       #+sbcl
       (and (sb-int:info :type :kind symbol)
            (not (find-class symbol nil)))
       #+ccl
       (and (ccl:type-specifier-p symbol)
            (not (find-class symbol nil)))
       #+ecl
       nil)
      (:special-operator
       (and (fboundp symbol)
            (special-operator-p symbol))))))

(defun symbol-documentation (symbol type)
  (flet ((doc (kind)
           (documentation symbol kind)))
    (case type
      (:variable
       (doc 'variable))
      ((:function :special-operator :generic-function :macro)
       (doc 'function))
      ((:structure :class :type)
       (doc 'type))
      (:compiler-macro
       (doc 'compiler-macro))
      (:setf
       (doc 'setf)))))

(defun list-symbol-bounding-types (symbol)
  (remove-if #'(lambda (type)
                 (not (symbol-bound-to symbol type)))
             *symbol-bounding-types*))

(defun symbol-object (symbol type)
  (ccase type
    (:variable
     (if (boundp symbol)
         (symbol-value symbol)
         :missing))
    ((:function :generic-function :special-operator)
     (when (fboundp symbol)
       (symbol-function symbol)))
    (:macro
     (macro-function symbol))
    ((:class :structure)
     (when (find-class symbol nil)
       (find-class symbol)))
    (:setf
     #+sbcl (swank/sbcl::setf-expander symbol)
     #+ccl nil
     #+ecl nil)
    (:type
     nil)
    (:compiler-macro
     (compiler-macro-function symbol))))

(defun package-location (symbol)
  (let ((definitions (swank::find-definitions symbol)))
    (let ((loc
            (cadr (find-if #'(lambda (x) (eq 'defpackage (caar x))) definitions))))
      (when (eq (car loc) :location)
                 (cons (cadr (assoc :file (cdr loc)))
                       (cadr (assoc :position (cdr loc))))))))

(defun symbol-location (symbol type)
  (let ((definitions (swank::find-definitions symbol)))
    (flet ((convert (ty)
             (let ((loc
                     (car (cdr (find-if #'(lambda (x) (eq ty (caar x))) definitions)))))
               (when (eq (car loc) :location)
                 (cons (cadr (assoc :file (cdr loc)))
                       (cadr (assoc :position (cdr loc)))))))
           (first1 ()
             (let ((loc
                     (car (cdr (car definitions)))))
               (when (and loc (eq (car loc) :location))
                 (cons (cadr (assoc :file (cdr loc)))
                       (cadr (assoc :position (cdr loc))))))))
      (ccase type
        (:function
         #+(or sbcl ecl)
         (convert 'defun)
         #+ccl
         (convert 'function))
        (:structure
         #+(or sbcl ecl)
         (convert 'defstruct)
         #+ccl
         (convert 'structure))
        (:class
         #+(or sbcl ecl)
         (convert 'defclass)
         #+ccl
         (convert 'class))
        (:macro
         #+(or sbcl ecl)
         (convert 'defmacro)
         #+ccl
         (convert 'function))
        (:generic-function
         #+(or sbcl ecl)
         (or (convert 'defgeneric)
             (convert 'defmethod))
         #+ccl
         (convert 'function))
        (:setf
         #+(or sbcl ecl)
         (convert 'define-setf-expander)
         #+ccl
         (first1))
        (:type
         #+sbcl
         (convert 'deftype)
         #+ccl
         (convert 'type))
        (:variable
         #+(or sbcl ecl)
         (convert 'defvar)
         #+ccl
         (convert 'variable))
        (:compiler-macro
         #+sbcl
         (convert 'define-compiler-macro)
         #+(or ccl ecl)
         nil)
        (:special-operator
         #+sbcl
         (convert 'defun)
         #+ecl
         (first1)
         #+ccl
         (convert 'function)))
      )))

(defun symbol-description (symbol type)
  (with-output-to-string (*standard-output*)
    (ccase type
      ((:variable nil)
       (describe symbol))
      ((:function :generic-function :special-operator)
       (when (fboundp symbol)
         (describe (symbol-function symbol))))
      (:macro
       (when (macro-function symbol)
         (describe (macro-function symbol))))
      ((or :class :structure)
       (when (find-class symbol nil)
         (describe (find-class symbol))))
      (:setf
       #+sbcl (when (sb-int:info :setf :expander symbol)
                (describe (sb-int:info :setf :expander symbol)))
       #+ccl (describe (ccl:setf-function-spec-name `(setf ,symbol)))
       #+ecl nil)
      (:type
       #+sbcl (describe (sb-kernel:values-specifier-type symbol))
       #+ccl (describe (or (find-class symbol nil) symbol))
       #+ecl nil)
      (:compiler-macro
       nil))))

#+nil(defun subclasses (class)
  (remove-duplicates (cons class
                           (mapcan #'subclasses (closer-mop:class-direct-subclasses class)))))

#+nil(defparameter *meta-classes*
  (append (lilu-apropos::subclasses (find-class 'standard-class))
          (lilu-apropos::subclasses (find-class 'standard-generic-function))
          (lilu-apropos::subclasses (find-class 'standard-method))))
